home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 60.zip / BS1 part 60 / Kick Pascal v2.10 d2.adf / DEMO / Play8SVX.p < prev    next >
Text File  |  1990-11-01  |  7KB  |  298 lines
  1. Program Play8SVX;
  2.  
  3. { Demo für die Benutzung des Audio-Device.              }
  4. { Die Funktion "LoadSample" lädt einen 8SVX-IFF-Sound,  }
  5. { legt ihn in einer dynamisch eingerichteten Struktur   }
  6. { ab und gibt einen Zeiger auf diese Struktur zurück.   }
  7. { Die Datei muß vor Aufruf von "LoadSample" bereits     }
  8. { geöffnet sein.                                        }
  9. { Die Prozedur "PlaySample" spielt den Sound dann ab.   }
  10. { Vorraussetzung ist, daß das Audio-Device geöffnet und }
  11. { initialisiert ist.                                    }
  12.  
  13. Uses ExecSupport, ExecIO;
  14.  
  15. {$incl 'devices/audio.h', "workbench/startup.h" }
  16.  
  17. Const
  18.   CLOCK = 3579545;
  19.  
  20.  
  21. Type
  22.   File8SVX = File of Byte;
  23.  
  24.   VHDRType = RECORD
  25.                OneShotHiSamples: Long;
  26.                RepeatHiSamples: Long;
  27.                SamplesPerHiCycle: Long;
  28.                SamplesPerSecond: Word;
  29.                Oktaven: Byte;
  30.                PackFlag: Byte;
  31.                Volume: Long
  32.              END;
  33.  
  34.   SamplePtr = ^SampleType;
  35.   SampleType = RECORD
  36.                  VHDR: VHDRType;
  37.                  Len: LongInt;
  38.                  Data: ARRAY[0..MaxLongInt] OF Short
  39.                END;
  40.  
  41.  
  42. Var F1                  : File8SVX;
  43.     Filename            : STRING;
  44.     MySample            : SamplePtr;
  45.     allocIOB, lockIOB   : ^IOAudio;
  46.     port                : ^MsgPort;
  47.     mydevice            : p_Device;
  48.     err                 : Long;
  49.  
  50.  
  51. Function LoadSample(VAR f: File8SVX): SamplePtr;
  52.   Type StrType = String[5];
  53.   Var sp: SamplePtr;
  54.       lw, err: LongInt;
  55.       s1: StrType;
  56.       HeadFlag, BodyFlag: Boolean;
  57.       VHDR: VHDRType;
  58.  
  59.   Function ReadStr4: StrType;
  60.     Var s: Array[1..5] OF Byte;
  61.         s2: String[5];
  62.     Begin
  63.       Read(f, s[1], s[2], s[3], s[4] );
  64.       s[5] := 0;
  65.       s2 := Str(^s);
  66.       ReadStr4 := S2;
  67.     End;
  68.  
  69.   Function ReadLong: LongInt;
  70.     Var b1, b2, b3, b4: Byte;
  71.     Begin
  72.       Read(f, b1, b2, b3, b4 );
  73.       ReadLong := Long( Long(b1 shl 8 + b2) shl 8 + b3) shl 8 + b4
  74.     End;
  75.  
  76.   Procedure Overread(Anz: LongInt);
  77.     Var b: Byte;
  78.     Begin
  79.       While Anz>0 DO
  80.         Begin
  81.           Read(f, b);
  82.           Dec(Anz)
  83.         End
  84.     End;
  85.  
  86.   Procedure ReadTo(Point: Ptr; Anz: Long );
  87.     Var p2: ^Array[1..MaxLongInt] Of Byte;
  88.         i: LongInt;
  89.     Begin
  90.       p2 := Point;
  91.       For i:=1 to Anz Do Read(f, p2^[i]);
  92.       { Blockread(f, p2^, Anz); }
  93.     End;
  94.  
  95.  
  96.   Begin    { LoadSample }
  97.     s1 := ReadStr4;
  98.     If s1 <> 'FORM' Then
  99.       Begin
  100.         Writeln('Kein IFF-Format!');
  101.         LoadSample := Nil;
  102.         Exit
  103.       End;
  104.     lw := ReadLong;
  105.     s1 := ReadStr4;
  106.     IF s1 <> '8SVX' THEN
  107.       Begin
  108.         Writeln('Kein 8SVX-File!');
  109.         LoadSample := Nil;
  110.         Exit
  111.       End;
  112.  
  113.     sp := Nil;
  114.     HeadFlag := false;
  115.     BodyFlag := false;
  116.  
  117.     While not (HeadFlag and BodyFlag) Do
  118.       Begin
  119.         s1 := ReadStr4;
  120.         lw := ReadLong;
  121.         IF s1='VHDR' THEN
  122.           Begin
  123.             ReadTo(^VHDR, SizeOf(VHDRType));
  124.             Overread(lw-SizeOf(VHDRType));
  125.             HeadFlag := true
  126.           End
  127.         Else
  128.         If s1='BODY' Then
  129.           Begin
  130.             If not HeadFlag Then
  131.               Begin
  132.                 Writeln('Fehler in Dateiformat!');
  133.                 LoadSample := Nil;
  134.                 Exit
  135.               End;
  136.             sp := Ptr (Alloc_Mem (lw+4+SizeOf(VHDRType), 2));
  137.             sp^.Len := lw+4+SizeOf(VHDRType);
  138.             sp^.VHDR := VHDR;
  139.             BlockRead(f, sp^.Data, lw);
  140.             BodyFlag := true
  141.           End
  142.         Else
  143.           OverRead(lw);
  144.  
  145.       End;
  146.  
  147.     LoadSample := sp
  148.   End;
  149.  
  150.  
  151.  
  152. Procedure InitAudio;
  153.   { Device öffnen, Ports einrichten, Kanäle reservieren usw. }
  154.   Var alloctable : Array[1..4] Of Byte;
  155.   Begin
  156.     port := CreatePort ('sound example', 0);
  157.     If port=Nil Then Halt(0);
  158.  
  159.     allocIOB := CreateExtIO (port, SizeOf (IOAudio));
  160.     If allocIOB=Nil Then Halt(0);
  161.  
  162.     lockIOB := CreateExtIO (port, SizeOf (IOAudio));
  163.     If lockIOB=Nil Then Halt(0);
  164.  
  165.     Open_Device(AUDIONAME, 0, AllocIOB, 0);
  166.  
  167.     mydevice := allocIOB^.ioa_Request.io_Device;
  168.     lockIOB^.ioa_Request.io_Device := mydevice;
  169.  
  170.     AllocTable[1] := %0001;
  171.     AllocTable[2] := %0010;
  172.     AllocTable[3] := %0100;
  173.     AllocTable[4] := %1000;
  174.  
  175.     With allocIOB^, ioa_Request, io_Message Do
  176.       Begin
  177.         io_Flags := ADIOF_NOWAIT;
  178.         ioa_Data := ^AllocTable;
  179.         ioa_Length := 4;
  180.         io_Command := ADCMD_ALLOCATE;
  181.         BeginIO(allocIOB);
  182.       End;
  183.     err := WaitIO(allocIOB);
  184.     If err <> 0 Then
  185.       Error('Allocation failed');
  186.  
  187.     With lockIOB^, ioa_Request Do
  188.       Begin
  189.         io_Unit := allocIOB^.ioa_Request.io_Unit;
  190.         io_Command := ADCMD_LOCK;
  191.         ioa_AllocKey := allocIOB^.ioa_AllocKey;
  192.       End;
  193.     SendIO(lockIOB);
  194.     If CheckIO(lockIOB) <> 0 Then
  195.       Error('Channel stolen.');
  196.   End;
  197.  
  198.  
  199.  
  200. Procedure PlaySample(s: SamplePtr);
  201.   Var Laenge,Rate: Long;
  202.   Begin
  203.     With s^.VHDR Do
  204.       Begin
  205.         Laenge := OneShotHiSamples+RepeatHiSamples;
  206.         Rate := CLOCK div SamplesPerSecond;
  207.       End;
  208.  
  209.     With lockIOB^, ioa_Request Do
  210.       Begin
  211.         io_Command := CMD_WRITE;
  212.         io_Flags := ADIOF_PERVOL;
  213.         ioa_Data := ^s^.Data;
  214.         ioa_Length := Laenge;
  215.         ioa_Volume := 64;
  216.         ioa_Period := Rate;
  217.         ioa_Cycles := 1;
  218.       End;
  219.     BeginIO(lockIOB);
  220.     If not fromWB Then writeln('Playing...');
  221.     err :=WaitIO(lockIOB)
  222.  End;
  223.  
  224.  
  225.  
  226. PROCEDURE StartVonWorkbench;
  227.   { Workbench-Parameter auswerten }
  228.   VAR StMess  : p_WBStartup;
  229.       OldLock : BPTR;
  230.   BEGIN
  231.     StMess := StartupMessage;
  232.       { "StartupMessage" ist ein typfreier "Ptr"-Pointer. Deshalb
  233.         wird zum Auswerten der Hilfszeiger "StMess" benötigt.    }
  234.     IF StMess^.sm_NumArgs < 2 THEN
  235.       { Anzahl der Argumente, d. h. der aktiven Icons. Das erste
  236.         Argument ist immer das Programm selbst. Also müssen mindestens
  237.         zwei Argumente vorhanden sein. }
  238.       Filename := ''
  239.     ELSE
  240.       WITH StMess^.sm_ArgList^[2] DO
  241.         BEGIN
  242.           { Als Datei wird das Argument Nr. #2 genommen. Falls noch
  243.             mehr Icons aktiviert sing (z. B. durch "Shift-Klick",
  244.             werden diese ignoroert. }
  245.           Filename := wa_Name;
  246.           { reiner Name ohne Pfad! Deshalb muss das aktuelle Verzeichnis
  247.             entsprechend gewählt werden:  }
  248.           OldLock := CurrentDir( wa_Lock );
  249.         END;
  250.   END;
  251.  
  252.  
  253. Begin { Main }
  254.  
  255.   { Dateinamen bestimmen }
  256.  
  257.   If FromWB Then
  258.     Begin
  259.       StartVonWorkbench;
  260.       If Filename = '' Then Exit
  261.     End
  262.   Else { Start von CLI }
  263.     Begin
  264.       Filename := ParameterStr;
  265.       If ParameterLen < 80 Then Filename[ParameterLen+1] := chr(0);
  266.       While Filename[1] = ' ' Do
  267.         Delete (Filename, 1, 1);    { führende Spaces löschen }
  268.       While (Filename <> '') and (Filename[Length(Filename)] <= ' ') Do
  269.         Filename[Length(Filename)] := chr(0);
  270.  
  271.       IF Filename='' Then
  272.         Begin
  273.           Writeln(#e'33mPlay8SVX'#e'31m - geschrieben von '#e'33mJens Gelhar'#&
  274.                   #e'31m 1990 mit Kickpascal 2.0');
  275.           Write('Dateiname : '); Readln(Filename);
  276.           If Filename='' Then Exit
  277.         End;
  278.     End;
  279.  
  280.   Reset (F1, Filename);
  281.   If IOResult <> 0 Then
  282.     Error('Datei konnte nicht geöffnet werden.');
  283.  
  284.   Buffer (F1, 5000);
  285.   If not FromWB Then Writeln ('Loading ', Filename, '...');
  286.   MySample := LoadSample (F1);
  287.   Close (F1);
  288.  
  289.   IF MySample <> Nil Then
  290.     Begin
  291.       InitAudio;
  292.       PlaySample(MySample);
  293.       Close_Device(allocIOB);
  294.     End;
  295.  
  296. End.
  297.  
  298.